home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Programmer Power Tools
/
Programmer Power Tools.iso
/
progjrn
/
pj_6_5.arc
/
OBJDRAW.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-08-18
|
10KB
|
328 lines
Copyright Tom Swan, 1988. All Rights Reserved.
PROGRAM ObjDraw;
{ Raw beginnings of an object-oriented graphics program,
demonstrating a practical use for variable-length data structures.
Written for Programmer's Journal by Tom Swan, Swan Software, P.O. Box
206, Lititz PA 17543. }
USES Crt, Graph;
CONST
FileName = 'OBJECTS.TXT'; { Graphics objects file name }
GrPath = 'C:\TPAS4'; { Pathname to BGI drivers }
MaxWord = 65535; { Maximum Word value }
TYPE
ObjType = ( {0} ObjPoint, {1} ObjLine, {2} ObjRect, {3} ObjCircle );
PointRec = { Single-pixel points }
RECORD
x, y : Integer; { Location of point }
pointColor : Word { Color of point }
END;
LineRec = { Straight lines }
RECORD
x1, y1, x2, y2 : Integer; { Line endpoints }
lineColor : Word { Line color }
END;
RectRec = { Squares and rectangles }
RECORD
x1, y1, x2, y2 : Integer; { Rectangle corners }
lineColor : Word; { Outline color }
fillColor : Word { Interior color (0=none) }
END;
CircleRec = { Circles }
RECORD
x, y : Integer; { Center coordinate }
radius : Word; { Length of radius in pixels }
lineColor : Word; { Outline color }
fillColor : Word { Interior color (0=none) }
END;
ObjPtr = ^ObjRec; { Pointer to various graphics objects }
ObjRec =
RECORD CASE objKind : ObjType OF
ObjPoint : ( onePoint : PointRec );
ObjLine : ( oneLine : LineRec );
ObjRect : ( oneRect : RectRec );
ObjCircle : ( oneCircle : CircleRec )
END;
ObjListPtr = ^ObjList; { Pointer to list of graphics objects }
ObjList =
RECORD
numObjects : Word; { Number of objects }
objects : ARRAY[ 0 .. 0 ] OF ObjPtr { Variable-length array }
END;
VAR
obj : ObjListPtr; { Pointer to list of objects }
PROCEDURE NewObjList( n : Word; VAR obj : ObjListPtr );
{ Return pointer obj to an ObjList record large enough to hold n
ObjPtr pointers in the obj^.objects array field. If obj=Nil on
return, then 1) n=0; or 2) bytes requested > MaxWord; or 3) enough
memory for n items is not available. }
VAR size : LongInt; { Number of bytes to allocate }
BEGIN
size := SizeOf( Word ) + ( LongInt(n) * SizeOf( ObjRec ) );
IF ( size = 0 ) OR ( size > MaxWord ) THEN obj := Nil ELSE
BEGIN
GetMem( obj, size ); { Out-of-memory error sets obj to Nil }
IF obj <> Nil
THEN obj^.numObjects := n
END { if }
END; { NewObjList }
PROCEDURE NewObj( n : Word; VAR obj : ObjPtr );
{ Return pointer obj to an ObjRec record large enough to hold n
bytes plus the record tag field. Out-of-memory error returns
obj = Nil. }
BEGIN
GetMem( obj, n + SizeOf( ObjType ) )
END; { NewObj }
FUNCTION NextObject( VAR f : Text ) : ObjPtr;
{ Read next object data from disk, creating an ObjRec record large
enough to hold the data, and returning the address of this record
as the function result. Out-of-memory error returns Nil. }
VAR objCode : Word; { Object code number (from data file) }
p : ObjPtr; { Temporary single object pointer }
FUNCTION LoadPoint : ObjPtr;
{ Load one point object }
BEGIN
NewObj( SizeOf( PointRec ), p ); { Allocate memory }
IF p <> Nil THEN WITH p^.onePoint DO
Read( f, x, y, pointColor ); { Read data }
LoadPoint := p { Return function result }
END; { LoadPoint }
FUNCTION LoadLine : ObjPtr;
{ Load one line object }
BEGIN
NewObj( SizeOf( LineRec ), p );
IF p <> Nil THEN WITH p^.oneLine DO
Read( f, x1, y1, x2, y2, lineColor );
LoadLine := p
END; { LoadLine }
FUNCTION LoadRect : ObjPtr;
{ Load one rectangle object }
BEGIN
NewObj( SizeOf( RectRec ), p );
IF p <> Nil THEN WITH p^.oneRect DO
Read( f, x1, y1, x2, y2, lineColor, fillColor );
LoadRect := p
END; { LoadRect }
FUNCTION LoadCircle : ObjPtr;
{ Load one circle object }
BEGIN
NewObj( SizeOf( CircleRec ), p );
IF p <> Nil THEN WITH p^.oneCircle DO
Read( f, x, y, radius, lineColor, fillColor );
LoadCircle := p
END; { LoadCircle }
BEGIN
Read( f, objCode ); { Read object code number }
CASE ObjType( objCode ) OF
ObjPoint : p := LoadPoint; { Read point data }
ObjLine : p := LoadLine; { Read line data }
ObjRect : p := LoadRect; { Read rectangle data }
ObjCircle : p := LoadCircle { Read circle data }
END; { case }
IF p <> Nil
THEN p^.objKind := ObjType( objCode ); { Save code as tag field }
NextObject := p { Return function result }
END; { NextObject }
PROCEDURE LoadFile( VAR obj : ObjListPtr );
{ Read graphics objects from a disk file. Halts on errors. }
VAR f : Text; { Text file variable }
n : Word; { Number of objects }
i : Word; { For-loop control variable }
BEGIN
Assign( f, FileName ); { Assign file name to file variable }
Reset( f ); { Open file for input }
Read( f, n ); { Read number of objects }
NewObjList( n, obj ); { Create array to hold list of n objects }
IF obj = Nil THEN { Check for bad n or short memory }
BEGIN
Writeln;
Writeln( 'Cannot allocate space for ', n, ' objects' );
Writeln( 'Memory available = ', MemAvail );
Halt(1)
END; { if }
FOR i := 1 TO n DO { Read n objects from disk }
obj^.objects[i-1] { Read next object and }
:= NextObject( f ); { assign to variable-length array }
Close( f )
END; { LoadFile }
PROCEDURE ShowOneObj( obj : ObjListPtr; n : Word );
{ Display object number n in object list addressed by obj pointer.
Assumes obj is not Nil. Ignores any Nil pointers in obj^.objects
array. }
VAR p : ObjPtr; { Holds copy of obj^.objects[n] }
PROCEDURE ShowPoint( VAR onePoint : PointRec );
{ Display point object }
BEGIN
WITH onePoint DO
PutPixel( x, y, pointColor )
END; { ShowPoint }
PROCEDURE ShowLine( VAR oneLine : LineRec );
{ Display Line object }
BEGIN
WITH oneLine DO
BEGIN
SetColor( lineColor );
Line( x1, y1, x2, y2 )
END { with }
END; { ShowLine }
PROCEDURE ShowRect( VAR oneRect : RectRec );
{ Display Rect object }
BEGIN
WITH oneRect DO
BEGIN
IF fillColor > 0 THEN
BEGIN
SetFillStyle( SolidFill, fillColor );
Bar( x1, y1, x2, y2 )
END; { if }
SetColor( lineColor );
Rectangle( x1, y1, x2, y2 )
END { with }
END; { ShowRect }
PROCEDURE ShowCircle( VAR oneCircle : CircleRec );
{ Display Circle object }
BEGIN
WITH oneCircle DO
BEGIN
SetColor( lineColor );
Circle( x, y, radius );
IF fillColor > 0 THEN
BEGIN
SetFillStyle( SolidFill, fillColor );
FloodFill( x, y, lineColor )
END { if }
END { with }
END; { ShowCircle }
BEGIN
WITH obj^ DO
IF ( 0 <= n ) AND ( n < numObjects ) THEN
BEGIN
p := objects[n];
IF p <> Nil THEN WITH p^ DO
CASE objKind OF
ObjPoint : ShowPoint( onePoint );
ObjLine : ShowLine( oneLine );
ObjRect : ShowRect( oneRect );
ObjCircle : ShowCircle( oneCircle )
END { case }
END { if }
END; { ShowOneObj }
PROCEDURE ShowAllObjects( obj : ObjListPtr );
{ Display all objects addressed by object list pointer obj. Assumes
that obj is not Nil. }
VAR i : Word; { For-loop control variable }
BEGIN
FOR i := 1 TO obj^.numObjects DO
ShowOneObj( obj, i - 1 );
END; { ShowAllObjects }
PROCEDURE DoGraphics( obj : ObjListPtr );
{ Initialize graphics screen and display objects addressed by obj. }
VAR grDriver, grMode, grError : Integer; { BGI graphics variables }
ch : Char; { Holds keypresses }
BEGIN
grDriver := Detect;
InitGraph( grDriver, grMode, grPath );
grError := GraphResult;
IF grError <> GrOk
THEN
Writeln( 'Graphics error : ', GraphErrorMsg( grError ) )
ELSE
BEGIN
ShowAllObjects( obj );
REPEAT
ch := ReadKey;
ShowOneObj( obj, ( Ord(ch) - Ord('0') ) - 1 )
UNTIL ch = Chr(27);
CloseGraph
END { else }
END; { DoGraphics }
{ The following custom heap-error trap function lets GetMem and New
return Nil pointers if memory allocation requests fail due to
insufficient memory. }
{$F+} { Switch on far-procedure generation }
FUNCTION HeapErrorTrap( size : Word ) : Integer;
BEGIN
HeapErrorTrap := 1 { New & GetMem: return Nil if out-of-memory }
END; { HeapErrorTrap }
{$F-} { Switch off far-procedure generation }
BEGIN
HeapError := @HeapErrorTrap; { Assign custom heap-error trap address }
Writeln;
Writeln( 'Welcome to ObjDraw' );
Writeln;
Writeln( 'Reads data from file ', FileName );
Writeln( 'Press digit keys to bring objects to the front' );
Writeln( 'Press Esc to quit' );
Writeln;
Write( 'Press Enter to begin...' );
Readln;
LoadFile( obj ); { Load objects from disk }
DoGraphics( obj ) { Display objects }
END.